home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / blackbox.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  6KB  |  230 lines
  1. ;  Blackbox game in Emacs Lisp
  2.  
  3. ;  by F. Thomas May
  4. ;  uw-nsr!uw-warp!tom@beaver.cs.washington.edu
  5.  
  6. (defvar blackbox-mode-map nil "")
  7.  
  8. (if blackbox-mode-map
  9.     ()
  10.   (setq blackbox-mode-map (make-keymap))
  11.   (suppress-keymap blackbox-mode-map t)
  12.   (define-key blackbox-mode-map "\C-f" 'bb-right)
  13.   (define-key blackbox-mode-map "\C-b" 'bb-left)
  14.   (define-key blackbox-mode-map "\C-p" 'bb-up)
  15.   (define-key blackbox-mode-map "\C-n" 'bb-down)
  16.   (define-key blackbox-mode-map "\C-e" 'bb-eol)
  17.   (define-key blackbox-mode-map "\C-a" 'bb-bol)
  18.   (define-key blackbox-mode-map " " 'bb-romp)
  19.   (define-key blackbox-mode-map "\C-m" 'bb-done))
  20.  
  21.  
  22. ;; Blackbox mode is suitable only for specially formatted data.
  23. (put 'blackbox-mode 'mode-class 'special)
  24.  
  25. (defun blackbox-mode ()
  26.   "Major mode for playing blackbox.
  27.  
  28. SPC -- send in a ray from point, or toggle a ball
  29. RET -- end game and get score
  30.  
  31. Precisely,\\{blackbox-mode-map}"
  32.   (interactive)
  33.   (kill-all-local-variables)
  34.   (use-local-map blackbox-mode-map)
  35.   (setq truncate-lines t)
  36.   (setq major-mode 'blackbox-mode)
  37.   (setq mode-name "Blackbox"))
  38.  
  39. (defun blackbox (num)
  40.   "Play blackbox.  Arg is number of balls."
  41.   (interactive "P")
  42.   (switch-to-buffer "*Blackbox*")
  43.   (blackbox-mode)
  44.   (setq buffer-read-only t)
  45.   (buffer-flush-undo (current-buffer))
  46.   (setq bb-board (bb-init-board (or num 4)))
  47.   (setq bb-balls-placed nil)
  48.   (setq bb-x -1)
  49.   (setq bb-y -1)
  50.   (setq bb-score 0)
  51.   (setq bb-detour-count 0)
  52.   (bb-insert-board)
  53.   (bb-goto (cons bb-x bb-y)))
  54.  
  55. (defun bb-init-board (num-balls)
  56.   (random t)
  57.   (let (board pos)
  58.     (while (>= (setq num-balls (1- num-balls)) 0)
  59.       (while
  60.       (progn
  61.         (setq pos (cons (logand (random) 7) (logand (random) 7)))
  62.         (bb-member pos board)))
  63.       (setq board (cons pos board)))
  64.     board))
  65.  
  66. (defun bb-insert-board ()
  67.   (let (i (buffer-read-only nil))
  68.     (erase-buffer)
  69.     (insert "                     \n")
  70.     (setq i 8)
  71.     (while (>= (setq i (1- i)) 0)
  72.       (insert "   - - - - - - - -   \n"))
  73.     (insert "                     \n")))
  74.  
  75. (defun bb-right ()
  76.   (interactive)
  77.   (if (= bb-x 8)
  78.       ()
  79.     (forward-char 2)
  80.     (setq bb-x (1+ bb-x))))
  81.  
  82. (defun bb-left ()
  83.   (interactive)
  84.   (if (= bb-x -1)
  85.       ()
  86.     (backward-char 2)
  87.     (setq bb-x (1- bb-x))))
  88.  
  89. (defun bb-up ()
  90.   (interactive)
  91.   (if (= bb-y -1)
  92.       ()
  93.     (previous-line 1)
  94.     (setq bb-y (1- bb-y))))
  95.  
  96. (defun bb-down ()
  97.   (interactive)
  98.   (if (= bb-y 8)
  99.       ()
  100.     (next-line 1)
  101.     (setq bb-y (1+ bb-y))))
  102.  
  103. (defun bb-eol ()
  104.   (interactive)
  105.   (setq bb-x 8)
  106.   (bb-goto (cons bb-x bb-y)))
  107.  
  108. (defun bb-bol ()
  109.   (interactive)
  110.   (setq bb-x -1)
  111.   (bb-goto (cons bb-x bb-y)))
  112.  
  113. (defun bb-romp ()
  114.   (interactive)
  115.   (cond
  116.    ((and
  117.      (or (= bb-x -1) (= bb-x 8))
  118.      (or (= bb-y -1) (= bb-y 8))))
  119.    ((bb-outside-box bb-x bb-y)
  120.     (bb-trace-ray bb-x bb-y))
  121.    (t
  122.     (bb-place-ball bb-x bb-y))))
  123.  
  124. (defun bb-place-ball (x y)
  125.   (let ((coord (cons x y)))
  126.     (cond
  127.      ((bb-member coord bb-balls-placed)
  128.       (setq bb-balls-placed (bb-delete coord bb-balls-placed))
  129.       (bb-update-board "-"))
  130.      (t
  131.       (setq bb-balls-placed (cons coord bb-balls-placed))
  132.       (bb-update-board "O")))))
  133.  
  134. (defun bb-trace-ray (x y)
  135.   (let ((result (bb-trace-ray-2
  136.          t
  137.          x
  138.          (cond
  139.           ((= x -1) 1)
  140.           ((= x 8) -1)
  141.           (t 0))
  142.          y
  143.          (cond
  144.           ((= y -1) 1)
  145.           ((= y 8) -1)
  146.           (t 0)))))
  147.     (cond
  148.      ((eq result 'hit)
  149.       (bb-update-board "H")
  150.       (setq bb-score (1+ bb-score)))
  151.      ((equal result (cons x y))
  152.       (bb-update-board "R")
  153.       (setq bb-score (1+ bb-score)))
  154.      (t
  155.       (setq bb-detour-count (1+ bb-detour-count))
  156.       (bb-update-board (format "%d" bb-detour-count))
  157.       (save-excursion
  158.     (bb-goto result)
  159.     (bb-update-board (format "%d" bb-detour-count)))
  160.       (setq bb-score (+ bb-score 2))))))
  161.  
  162. (defun bb-trace-ray-2 (first x dx y dy)
  163.   (cond
  164.    ((and (not first)
  165.      (bb-outside-box x y))
  166.     (cons x y))
  167.    ((bb-member (cons (+ x dx) (+ y dy)) bb-board)
  168.     'hit)
  169.    ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)
  170.     (bb-trace-ray-2 nil x (- dy) y (- dx)))
  171.    ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
  172.     (bb-trace-ray-2 nil x dy y dx))
  173.    (t
  174.     (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
  175.  
  176. (defun bb-done ()
  177.   (interactive)
  178.   (let (bogus-balls)
  179.     (if (not (= (length bb-balls-placed) (length bb-board)))
  180.     (message "Spud!  You have only %d balls in the box."
  181.          (length bb-balls-placed))
  182.       (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
  183.       (if (= bogus-balls 0)
  184.       (message "Right!  Your score is %d." bb-score)
  185.     (setq bb-score (+ bb-score (* 5 bogus-balls)))
  186.     (message "Veg!  You missed %d balls.  Your score is %d."
  187.          bogus-balls bb-score))
  188.       (bb-goto '(-1 . -1)))))
  189.  
  190. (defun bb-show-bogus-balls (balls-placed board)
  191.   (bb-show-bogus-balls-2 balls-placed board "x")
  192.   (bb-show-bogus-balls-2 board balls-placed "o"))
  193.  
  194. (defun bb-show-bogus-balls-2 (list-1 list-2 c)
  195.   (cond
  196.    ((null list-1)
  197.     0)
  198.    ((bb-member (car list-1) list-2)
  199.     (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
  200.    (t
  201.     (bb-goto (car list-1))
  202.     (bb-update-board c)
  203.     (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
  204.  
  205. (defun bb-outside-box (x y)
  206.   (or (= x -1) (= x 8) (= y -1) (= y 8)))
  207.  
  208. (defun bb-goto (pos)
  209.   (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
  210.  
  211. (defun bb-update-board (c)
  212.   (let ((buffer-read-only nil))
  213.     (backward-char (1- (length c)))
  214.     (delete-char (length c))
  215.     (insert c)
  216.     (backward-char 1)))
  217.   
  218. (defun bb-member (elt list)
  219.   "Returns non-nil if ELT is an element of LIST.  Comparison done with equal."
  220.   (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list))))
  221.  
  222. (defun bb-delete (item list)
  223.   "Deletes ITEM from LIST and returns a copy."
  224.   (cond
  225.    ((equal item (car list)) (cdr list))
  226.    (t (cons (car list) (bb-delete item (cdr list))))))
  227.  
  228.  
  229.  
  230.